home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
graphic
/
postogrf.zip
/
WRITEPRT.INC
< prev
Wrap
Text File
|
1990-05-21
|
9KB
|
222 lines
Procedure WritePrt;
var s:string[10]; i:word;
XPos, Ypos, error, temp1 : integer;
PenDia, nn : word;
str1 : string80;
buffPtr : FilePtr;
procedure writeescape(var outdev:text; s:string);
const escapers : set of char = ['(', ')', '\' ];
var i1:byte;
begin for i1 := 1 to length(s)
do begin if s[i1] in escapers then write(outdev, '\', s[i1])
else write(outdev, s[i1]);
end; {do}
end; {writeEscape}
{ write all font generation commands before }
{ ---------------------------------------------------------------------
Generate fonts without duplication. Add header code for MITRELogo
font if it will be used.
----------------------------------------------------------------------}
procedure ScanWriteFonts;
var i3:byte;
type FontSpec = record
TFont: FontList; {type face - Helv. bold, etc}
TSize: integer; {font size in points}
FontStr: string[80]; {string to make fonts}
FontNum: integer; {font ID number}
end;
var Fonts : array[0..20] of FontSpec;
TempFont : FontSpec;
i1, i2 : byte;
PointSize, fNumStr: string[7];
procedure MakeFontString(var Text: FontSpec);
begin
Str(round(1000*(Text.TSize/72)), PointSize);
Str(Text.FontNum, fNumStr);
Text.fontStr :=
'/font' + fNumStr + ' /' + POSTStyleStr[Text.TFont]
+ ' findfont ' + PointSize + ' scalefont def';
end; {MakeFontString}
{ -----------------------------------------------------------------
delete redundant fonts by scanning all the fonts & replacing them
by a previously specified font if the same font was requested
already.
array Fonts will end up containing one copy of each font specification
and descriptor string (up to 20 fonts).
----------------------------------------------------------------- }
procedure ScanFonts(var i1, i2:byte);
{ ----------------------------------------------------------------
Test for match of font temp^ to an entry in Fonts[]. i1 points to
last entry in Fonts, i2 points to match on return. If no match,
i2 = succ(i1) on return. Test for MITRELogo font & set flag
if it is called.
---------------------------------------------------------------- }
begin
i2 := 0;
with TempFont do begin
TFont := temp^.LipsFont.LipsStyle;
Tsize := temp^.PrtSize;
end; {do}
{ ----- scan until style & size match or end of list ----- }
repeat inc(i2)
until (i2 > i1) or ((TempFont.TFont = Fonts[i2].TFont) and
(TempFont.TSize = Fonts[i2].TSize));
With TempFont do begin
FontNum := i2{temp^.LIPSFont.FontNum};
MakeFontString(TempFont);
if Tfont = MitreLogo then Lconfig.writeMitreLogo := true;
end;
end; {ScanFonts}
procedure CondenseFonts;
begin
{i1 points to end of list of fonts in Fonts}
temp:= head; i1 := 0;
with Fonts[0] do begin {initialize Fonts to include}
Tfont := HelvBold; TSize := 13; {font1, which will be used}
FontStr := JimDefFontStr; {for GRAPHLI numeric labels}
FontNum := 0;
end; {with}
repeat
ScanFonts(i1, i2);
if i2 > i1 {didn't find this font}
then begin Fonts[i2] := TempFont; {so add it }
inc(i1); {increment pointer}
end;
temp^.LIPSFont.fontStr := Fonts[i2].FontStr;
temp^.LIPSFont.FontNum := Fonts[i2].FontNum;
temp := temp^.link;
until temp = nil;
end; {condenseFonts}
begin {ScanWriteFonts}
writeln(PrtFile, '%FontDefinitions');
writeln(PrtFile, font0str);
if head = nil then begin { omit if no labels }
writeln(PrtFile, '%EndFonts');
exit;
end;
CondenseFonts;
if LConfig.writeMitreLogo then WriteMitreLogo;
LConfig.WriteMitreLogo := false;
for i3 := 1 to i1 do
writeln(PrtFile, Fonts[i3].FONTStr);
writeln(PrtFile, '%EndFonts');
end; {ScanWriteFonts}
procedure ScanWriteLabels; { write my labels before Jim's graph stuff }
begin if head = nil then exit { no labels}
else cp := head;
repeat
writeln(PrtFile, 'font', cp^.LIPSFont.FontNum, ' sf');
outprconv(cp);
writeln(PrtFile, HorizPrinterDots, ' ' ,
VertPrinterDots, ' m');
write(PrtFile, '(');
writeEscape(prtFile,cp^.tstr);
write(PrtFile, ')');
if cp^.LabelBkGround = trans then
if cp^.CurrText.Direction = HorizDir
then writeln(PrtFile,' show') else
writeln(PrtFile, ' rsho') else
if cp^.CurrText.Direction = HorizDir
then writeln(PrtFile, ' s')
else writeln(PrtFile, ' rs');
cp := cp^.link;
until cp = nil;
end; {ScanWriteLabels}
begin {WritePrt}
if PrtFileName = '' then exit ; { no file to write to }
writeln; write('writing output file ', prtFilename);
{$I-}
PostHd2;
ScanWriteFonts;
writeln(PrtFile, '%%EndProlog');
PSSetup;
done := false;
here := JimFileStart;
writeln(PrtFile, '%StartGraph');
if not (JimFileblock = 0) then begin
case GraphFile of
GRAPHL, LIPSGRF: begin
writeln(PrtFile, 'font0 sf');
if count > 0 then
Repeat
GetAWord(str1);
if (str1 = 'EXIT') or (str1 = 'PAGE') then begin
done := true;
end ELSE
{if str1 = 'PAGE' then writeln(PrtFile, 'showpage') ELSE}
if str1 = 'MAP' then { move to position }
begin GetAWord(str1); Val(str1,Xpos,error); (* *** ADD ERROR CHECKING *)
GetAWord(str1); Val(str1,Ypos,error);
OutPrPos(Xpos, YPos);
writeln(PrtFile, Xpos,' ', YPos, ' m');
end ELSE
if str1 = 'DAP' then { draw to position }
begin GetAWord(str1); Val(str1,Xpos,error); (* *** ADD ERROR CHECKING *)
GetAWord(str1); Val(str1,Ypos,error);
OutPrPos(XPos,YPos);
writeln(PrtFile,Xpos,' ', YPos, ' l');
{writeln(PrtFile, 'cpt st m');}
end ELSE
if str1 = 'SPD' then { set pen diameter - only an approximation }
begin GetAWord(str1); Val(str1,PenDia, error); (* *** ADD ERROR CHECK *)
PenDia := PenDia * 10 div 3;
writeln(PrtFile, 'cpt st m');
writeln(PrtFile, PenDia, ' setlinewidth');
end ELSE
if str1 = 'FONT' then { use font0 for GRAPH-supplied labels }
begin
GetAWord(str1);
if str1 = '3' then
writeln(PrtFile, 'font0 sf');
end ELSE
if str1 = 'TEXT' then { write the following text string }
begin
writeln(PrtFile, 'cpt st m');
GetAQuote(str1);
writeln(PrtFile,'(', str1,')', ' show');
end ELSE (* nothing *);
until done = true ;
writeln(PrtFile, '%EndGraph');
EndGraph := here;
if GRAPHLIName <> '' then begin
writeln(PrtFile, 'stroke');
end;
end; {case GRAPHL, LIPSGRF}
POSTSCRIPT: begin
for nn := StartGraph to EndGraph - 1 do
write(PrtFile, JimFile^[nn]);
end; {